BBS Toolkit/BBS Toolkit.iso/doors_1/fd200.zip/AVL_TREE.PAS

Pascal/Delphi Source File | 1988-02-27 | 12.7 KB | 436 lines

type  balance = ( L, B, R );

      LINK = ^Branch;

      Branch  = record
                 leaf     : data;
                 left     : LINK;
                 right    : LINK;
                 bal      : balance;
                end;


{ ***********   CONSTANTS, AND VARIABLES FOR AV Lists ********** }

const on_bit  : array[0..15] of word =
                ( $0001,$0002,$0004,$0008,$0010,$0020,$0040,$0080,
                  $0100,$0200,$0400,$0800,$1000,$2000,$4000,$8000 );
      off_bit : array[0..15] of word =
                ( $FFFE,$FFFD,$FFFB,$FFF7,$FFEF,$FFDF,$FFBF,$FF7F,
                  $FEFF,$FDFF,$FBFF,$F7FF,$EFFF,$DFFF,$BFFF,$7FFF );
      depth : integer = -1;
      h     : integer = 0;      { Set by recursive calls to search to
                               indicate that the tree has grown.
                               It will magically change its value
                               everytime ins() is called recursively. }

var  Newnode,
     Conflicting,
     AvlKey,
     root,
     tbranch,
     p            : LINK;
     Notfound     : boolean;
     map : array[0..1023] of integer;
     n,i : integer;



{ ***********   SPECIFIC PROCEDURES AND FUNCTION FOR AV Lists ********** }

function talloc: LINK;
var p : LINK;
begin
  New(p);
  if p <> NIL then
    with p^ do
    begin
      left := NIL;
      right := NIL;
      bal   := B;
    end;
  talloc := p;
end;

procedure tfree( var p : LINK);
begin
  dispose(p);
end;

function testbit(c: integer): integer;
begin
 testbit := Map[ c SHR 4] AND (on_bit[c AND $0F]);
end;

procedure  setbit( c, val : integer);
begin
   if (val <> 0)
   then
      Map[c SHR 4] := Map[c SHR 4] OR (on_bit[(c AND $0F)])
   else
      Map[c SHR 4] := Map[c SHR 4] AND (off_bit[(c AND $0F)]) ;
end;

procedure trav(root : LINK; direction: balance; device : integer);
label trav_exit;
var i : integer;
begin
   if (root <> NIL) AND (escape = FALSE) then
   begin
     depth := depth + 1;
     if (root^.left <> NIL)
       then trav(root^.left,R, device)
       else setbit(depth + 1,1);
     if (escape = TRUE) then goto trav_exit;
     if device = 0 then print(root^.leaf)
                   else fprint(root^.leaf);
     if direction = L then setbit(depth, 0)
                      else setbit(depth, 1);
     if (root^.right <> NIL)
     then  trav(root^.right, L, device)
     else  setbit(depth + 1, 0);
     depth := depth - 1;
   end;
trav_exit:
end;

procedure tprint(root : LINK);
var i : integer;
begin
   escape := FALSE;
   for i := 0 to 1023 do map[i] := 0;
   depth := -1;
   trav( root, R, 0);
end;

function find( root, key : LINK ): LINK;
begin
   if ( root = NIL )
     then  find := NIL
     else  case cmp( key^.leaf, root^.leaf) of
             -1 : find := find(root^.left, key);
              0 : find := root;
              1 : find := find(root^.right, key);
           end;
end;

procedure ins( var pp : LINK );
var  p, p1, p2 : LINK;
begin
   p := pp;
   if ( p = NIL )
   then
     begin
        p := Newnode;
        h := 1;
     end
   else
     case cmp(newnode^.leaf, p^.leaf) of
        0 : Conflicting := p;
       -1 : begin
              ins( p^.left );
              if ( h > 0 ) then
              case p^.bal of
                 R: begin
                      p^.bal := B;
                      h := 0;
                    end;
                 B: p^.bal := L;
                 L: begin
                      p1 := p^.left;
                      if ( p1^.bal = L )
                      then begin
                             p^.left   := p1^.right;
                             p1^.right := p;
                             p^.bal    := B;
                             p         := p1;
                           end
                      else begin
                             p2          := p1^.right;
                             p1^.right   := p2^.left;
                             p2^.left    := p1;
                             p^.left     := p2^.right;
                             p2^.right   := p;
                             if (p2^.bal = L)
                               then p^.bal := R
                               else p^.bal := B;
                             if (p2^.bal = R)
                               then p1^.bal := L
                               else p1^.bal := B;
                             p := p2;
                           end;
                      p^.bal := B;
                      h      := 0;
                    end;
              end;
            end;
        1 : begin
              ins( p^.right );
              if ( h > 0 ) then
              case  p^.bal  of
                L: begin
                     p^.bal := B;
                     h := 0;
                   end;
                B: p^.bal := R;
                R: begin
                     p1 := p^.right;
                     if ( p1^.bal = R )
                     then
                       begin
                         p^.right := p1^.left;
                         p1^.left := p;
                         p^.bal   := B;
                         p        := p1;
                       end
                     else
                       begin
                         p2        := p1^.left;
                         p1^.left  := p2^.right;
                         p2^.right := p1;
                         p^.right  := p2^.left;
                         p2^.left  := p;
                         if (p2^.bal = R)
                           then p^.bal := L
                           else p^.bal := B;
                         if (p2^.bal = L)
                           then p1^.bal := R
                           else p1^.bal := B;
                         p           := p2;
                       end;
                    p^.bal := B;
                    h      := 0;
                  end;
              end;
            end;
     end;
     pp := p;
end;

procedure insert( var rootp, netbrnch : LINK);
begin
{ Insert newnode into tree pointed to by rootp.  Cmp is passed
  Return NIL on success or a pointer to the conflicting node
  on error.
}
   h := 0;
   Newnode := netbrnch;
   Conflicting := NIL;
   ins(rootp);
   if Conflicting <> NIL then tfree(netbrnch);
end;

function balance_l( var pp : LINK ): boolean;

{ This routine is called when the left branch of the current
  subtree (pointed to by p) has shrunk.  It adjusts the balance
  factors and rebalances if necessary, modifying *pp to point
  at the new root (after the rebalance).  Returns TRUE if the
  tree got smaller as a result of the delete or the rebalance
  operation, else returns 0.
}
var p, p1, p2 : LINK;
    b1, b2    : balance;
    got_smaller : boolean;

begin
  got_smaller := TRUE;
  p := pp;
  case p^.bal of
    L: p^.bal := B;
    B: begin
         p^.bal := R;
         got_smaller := FALSE;
       end;
    R: begin
         p1 := p^.right;
         b1 := p1^.bal;
         if ( b1 <> L )
         then begin
                p^.right := p1^.left;
                p1^.left := p;
                if ( b1 <> B )
                then begin
                       p^.bal := B;
                       p1^.bal := B;
                     end
                else begin
                       p^.bal := R;
                       p1^.bal := L;
                       got_smaller := FALSE;
                     end;
                p := p1;
              end
            else begin
                   p2         := p1^.left;
                   b2         := p2^.bal;
                   p1^.left   := p2^.right;
                   p2^.right  := p1;
                   p^.right   := p2^.left;
                   p2^.left   := p;
                   case b2 of
                     R    : p^.bal := L;
                     B, L : p^.bal := B;
                   end;
                   case b2 of
                     L    : p1^.bal := R;
                     B, R : p1^.bal := B;
                   end;
                   p           := p2;
                   p2^.bal     := B;
                 end;
       end;
   end;
   pp := p;
   balance_l := got_smaller;
end;


function balance_r( var pp : LINK ): boolean;
{ same as balance_l, but is called when a right subtree has
  been made smaller.
}
var p, p1, p2 : LINK;
   b1, b2     : balance;
   got_smaller : boolean;
begin
  got_smaller := TRUE;
  p := pp;
  case p^.bal of
    R: p^.bal := B;
    B: begin
         p^.bal := L;
         got_smaller := FALSE;
       end;
    L: begin
         p1 := p^.left;
         b1 := p1^.bal;
         if ( b1 <> R )
         then begin
                p^.left     := p1^.right;
                p1^.right   := p;
                if ( b1 <> B )
                then p^.bal := B
                else begin
                       p^.bal      := L;
                       p1^.bal     := R;
                       got_smaller := FALSE;
                     end;
                p := p1;
              end
         else begin
                p2          := p1^.right;
                b2          := p2^.bal;
                p1^.right   := p2^.left;
                p2^.left    := p1;
                p^.left     := p2^.right;
                p2^.right   := p;
                case b2 of
                  L   : p^.bal := R;
                  B,R : p^.bal := B;
                end;
                case b2 of
                  R   : p1^.bal := L;
                  B,L : p1^.bal := R;
                end;
                p           := p2;
                p2^.bal     := B;
              end;
       end;
  end;
  pp := p;
  balance_r := got_smaller;
end;

function descend( var  rootp, dpp : LINK): boolean;
{ rootp     address of root of current node
  dpp       address of node to be deleted

  Does the actual delete when the root node has both left and
  right descendents.  Descends to the rightmost node of the left
  subtree and then copies the contents of that node to the
  node-to-be-deleted (dpp).  Then the node-to-be-deleted is
  modified to point to the former rightmost node.
}
begin
  if ( rootp^.right <> NIL )
  then
    case descend( rootp^.right, dpp) of
      FALSE  : descend := FALSE;
      TRUE   : descend := balance_r(rootp) ;
    end
  else begin
         move(rootp^.leaf,dpp^.leaf,sizeof(data));
         dpp := rootp;
         rootp := rootp^.left;
         descend := TRUE;
       end;
end;

function del(var  rootp : LINK ): boolean;
{
  Delete AvlKey from tree pointed to by rootp.  Return TRUE if the size
  of the tree has been reduced, FALSE otherwise.
}
var  dp : LINK;      { pointer to node to delete }
     got_smaller : boolean;
begin
   got_smaller := FALSE;  { set TRUE if tree shrinks  }
   if ( rootp = NIL )
   then Notfound := TRUE
   else begin
          case cmp(AvlKey^.leaf, rootp^.leaf) of
            -1 : if ( del(rootp^.left) = TRUE )
                 then got_smaller := balance_l( rootp ) ;
             1 : if ( del(rootp^.right) = TRUE )
                 then got_smaller := balance_r( rootp ) ;
             0 : begin
                   case check_if_ok(rootp^.leaf) of
                     -1 : Notfound := TRUE;
                      0 : if (del(rootp^.right) = TRUE)
                          then got_smaller := balance_r(rootp);
                      1 : begin
                            dp := rootp;
                            if ( dp^.right = NIL )
                            then begin
                                   rootp      := dp^.left;
                                   got_smaller := TRUE;
                                 end
                            else if ( dp^.left = NIL )
                                 then begin
                                        rootp := dp^.right;
                                        got_smaller := TRUE;
                                      end
                                 else if ( descend(rootp^.left, dp ) = TRUE )
                                      then got_smaller := balance_l( rootp ) ;
                            tfree( dp );
                          end;
                   end;
                 end;
           end;
         end;
  del := got_smaller;
end;


function  delete( var rootp, pass : LINK ): boolean;
var dmy : boolean;
{
  Cmp is a comparison routine with two leaf records passed to
  it.  It should return

       -1 if key < node;
        0 if key = node;
        1 if key > node.

  DELETE returns 1 if the node was deleted,
                 0 if the node wasn't in the tree.
}
begin
  AvlKey := pass;
  Notfound := FALSE;
  dmy :=  del( rootp );
  delete := NOT Notfound;
end;